home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 68.7z / BS1 part 68 / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).7z / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).adf / PC_Tools.LZH / ALISP.ZIP / 3DWIN.LSP < prev    next >
Lisp/Scheme  |  1993-10-06  |  4KB  |  84 lines
  1. ;  This was written to put "windows" (rectangular holes) in walls of 3D houses
  2. ;  Type "3dwin", then respond to prompt by picking a 3DFACE
  3. ;  Then respond to further prompts by picking the opposite corners of
  4. ;  the rectangular window.
  5. ;
  6. ;  The "wall" will be replaced with four new 3DFACEs, with appropriate
  7. ;  invisible edges, to form an apparent solid wall with an opening.
  8. ;
  9. ;  When picking the window corners, do not go beyond the edges of the
  10. ;  original 3DFACE.
  11. ;
  12. (write-line "3DWIN  Copyright 1991 James White, Whiteware, St. Louis MO")
  13. ;  Messages to Compuserve 72060,1152 or write 8544 Bryan, St. Louis 63117.
  14. ;
  15. ;  Use for home, hobby and trial use is licensed.  If used professionally,
  16. ;  please register for $10 (single machine) or ask about site license or
  17. ;  trade similar 3D Lisp utilities.
  18.  
  19. (defun c:3dwin ()
  20.   (setvar "cmdecho" 0)
  21. ; pick a 3dface
  22.   (setq count 0)
  23.   (while (not (= count 1))
  24.     (if (not (= count 1))
  25.         (setq ss (entsel))); if
  26.     (if (= "3DFACE" (cdr (assoc 0 (entget (car ss)))))
  27.       (setq count 1)
  28.       (prompt "Not a 3DFace")); if
  29.   ); while
  30.   (redraw (car ss) 3)
  31. ; get its corners
  32.   (setq d1 (cdr (assoc 10 (entget (car ss))))
  33.         d2 (cdr (assoc 11 (entget (car ss))))
  34.         d3 (cdr (assoc 12 (entget (car ss))))
  35.         d4 (cdr (assoc 13 (entget (car ss))))
  36.         invis (cdr (assoc 70 (entget (car ss)))))
  37. ; save current ucs and set new one on 3dface
  38.   (command "ucs" "save" "temucs" "y")
  39.   (command "ucs" "3" d1 d2 d3)
  40. ; pick window corners
  41.   (setq p1 (getpoint "Select window corner...")
  42.         p2 (getpoint "Select opposite window corner..." p1))
  43. ; get 4 corners of window
  44.   (setq f1 p1
  45.         f2 (list (car p2) (cadr p1) (caddr p1))
  46.         f3 p2
  47.         f4 (list (car p1) (cadr p2) (caddr p2)))
  48. ; translate window corners to wcs
  49.   (setq f1 (trans f1 1 0)
  50.         f2 (trans f2 1 0)
  51.         f3 (trans f3 1 0)
  52.         f4 (trans f4 1 0))
  53. ; orient window corners to wall corners
  54.   (if (> (distance d1 f1) (distance d1 f2))
  55.       (progn (setq p1 f1) (setq f1 f2) (setq f2 p1)))
  56.   (if (> (distance d1 f1) (distance d1 f3))
  57.       (progn (setq p1 f1) (setq f1 f3) (setq f3 p1)))
  58.   (if (> (distance d1 f1) (distance d1 f4))
  59.       (progn (setq p1 f1) (setq f1 f4) (setq f4 p1)))
  60.   (if (> (distance d2 f2) (distance d2 f3))
  61.       (progn (setq p1 f2) (setq f2 f3) (setq f3 p1)))
  62.   (if (> (distance d2 f2) (distance d2 f4))
  63.       (progn (setq p1 f2) (setq f2 f4) (setq f4 p1)))
  64.   (if (> (distance d3 f3) (distance d3 f4))
  65.       (progn (setq p1 f3) (setq f3 f4) (setq f4 p1)))
  66. ; set wcs for correct 3dface and make new faces
  67.   (command "ucs" "w")
  68.   (if (= 1 (logand 1 invis)) (command "3dface" "i" d1 "i" d2 f2 "i" f1 "")
  69.                              (command "3dface" d1 "i" d2 f2 "i" f1 ""))
  70.   (if (= 2 (logand 2 invis)) (command "3dface" "i" d2 "i" d3 f3 "i" f2 "")
  71.                              (command "3dface" d2 "i" d3 f3 "i" f2 ""))
  72.   (if (= 4 (logand 4 invis)) (command "3dface" "i" d3 "i" d4 f4 "i" f3 "")
  73.                              (command "3dface" d3 "i" d4 f4 "i" f3 ""))
  74.   (if (= 8 (logand 8 invis)) (command "3dface" "i" d4 "i" d1 f1 "i" f4 "")
  75.                              (command "3dface" d4 "i" d1 f1 "i" f4 ""))
  76. ; delete the old wall and clean up
  77.   (command "erase" ss "")
  78.   (command "redraw")
  79.   (command "ucs" "r" "temucs")
  80.   (setvar "cmdecho" 1)
  81. ); defun
  82. (prompt "\n        Copyright 1991 James H. White")
  83. (prompt "\n      type '3dwin' to  perforate 3dface")
  84. (princ)